home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / mislib.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  3KB  |  89 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;; This file is IMPLEMENTATION-DEPENDENT.
  6.  
  7.  
  8. (in-package 'lisp)
  9.  
  10.  
  11. (export 'time)
  12. (export '(decode-universal-time encode-universal-time))
  13.  
  14.  
  15. (in-package 'system)
  16.  
  17.  
  18. (proclaim '(optimize (safety 2) (space 3)))
  19.  
  20.  
  21. (defmacro time (form)
  22.   `(let (real-start real-end run-start run-end x)
  23.      (setq real-start (get-internal-real-time))
  24.      (setq run-start (get-internal-run-time))
  25.      (setq x (multiple-value-list ,form))
  26.      (setq run-end (get-internal-run-time))
  27.      (setq real-end (get-internal-real-time))
  28.      (fresh-line *trace-output*)
  29.      (format *trace-output*
  30.              "real time : ~,3F secs~%~
  31.               run time  : ~,3F secs~%"
  32.              (/ (- real-end real-start) internal-time-units-per-second)
  33.              (/ (- run-end run-start) internal-time-units-per-second))
  34.      (values-list x)))
  35.  
  36.  
  37. (defconstant month-days-list '(31 28 31 30 31 30 31 31 30 31 30 31))
  38. (defconstant seconds-per-day #.(* 24 3600))
  39.  
  40. (defun leap-year-p (y)
  41.   (and (zerop (mod y 4))
  42.        (or (not (zerop (mod y 100))) (zerop (mod y 400)))))
  43.  
  44. (defun number-of-days-from-1900 (y)
  45.   (let ((y1 (1- y)))
  46.     (+ (* (- y 1900) 365)
  47.        (floor y1 4) (- (floor y1 100)) (floor y1 400)
  48.        -460)))
  49.  
  50. (defun decode-universal-time (ut &optional (tz *default-time-zone*))
  51.   (let (sec min h d m y dow)
  52.     (decf ut (* tz 3600))
  53.     (multiple-value-setq (d ut) (floor ut seconds-per-day))
  54.     (setq dow (mod d 7))
  55.     (multiple-value-setq (h ut) (floor ut 3600))
  56.     (multiple-value-setq (min sec) (floor ut 60))
  57.     (setq y (+ 1900 (floor d 366)))  ; Guess!
  58.     (do ((x))
  59.         ((< (setq x (- d (number-of-days-from-1900 y)))
  60.             (if (leap-year-p y) 366 365))
  61.          (setq d (1+ x)))
  62.       (incf y))
  63.     (when (leap-year-p y)
  64.           (when (= d 60)
  65.                 (return-from decode-universal-time
  66.                              (values sec min h 29 2 y dow nil tz)))
  67.           (when (> d 60) (decf d)))
  68.     (do ((l month-days-list (cdr l)))
  69.         ((<= d (car l)) (setq m (- 13 (length l))))
  70.       (decf d (car l)))
  71.     (values sec min h d m y dow nil tz)))
  72.  
  73. (defun encode-universal-time (sec min h d m y
  74.                               &optional (tz *default-time-zone*))
  75.   (incf h tz)
  76.   (when (<= 0 y 99)
  77.         (multiple-value-bind (sec min h d m y1 dow dstp tz)
  78.             (get-decoded-time)
  79.           (declare (ignore sec min h d m dow dstp tz))
  80.           (incf y (- y1 (mod y1 100)))
  81.           (cond ((< (- y y1) -50) (incf y 100))
  82.                 ((>= (- y y1) 50) (decf y 100)))))
  83.   (unless (and (leap-year-p y) (> m 2)) (decf d 1))
  84.   (+ (* (apply #'+ d (number-of-days-from-1900 y)
  85.                (butlast month-days-list (- 13 m)))
  86.         seconds-per-day)
  87.      (* h 3600) (* min 60) sec))
  88.  
  89.